home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl67.lha / tcl6.7 / tclCmdAH.c < prev    next >
C/C++ Source or Header  |  1993-01-29  |  22KB  |  915 lines
  1. /* 
  2.  * tclCmdAH.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    A to H.
  7.  *
  8.  * Copyright 1987-1991 Regents of the University of California
  9.  * Permission to use, copy, modify, and distribute this
  10.  * software and its documentation for any purpose and without
  11.  * fee is hereby granted, provided that the above copyright
  12.  * notice appear in all copies.  The University of California
  13.  * makes no representations about the suitability of this
  14.  * software for any purpose.  It is provided "as is" without
  15.  * express or implied warranty.
  16.  */
  17.  
  18. #ifndef lint
  19. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.79 93/01/29 14:36:00 ouster Exp $ SPRITE (Berkeley)";
  20. #endif
  21.  
  22. #include "tclInt.h"
  23.  
  24.  
  25. /*
  26.  *----------------------------------------------------------------------
  27.  *
  28.  * Tcl_BreakCmd --
  29.  *
  30.  *    This procedure is invoked to process the "break" Tcl command.
  31.  *    See the user documentation for details on what it does.
  32.  *
  33.  * Results:
  34.  *    A standard Tcl result.
  35.  *
  36.  * Side effects:
  37.  *    See the user documentation.
  38.  *
  39.  *----------------------------------------------------------------------
  40.  */
  41.  
  42.     /* ARGSUSED */
  43. int
  44. Tcl_BreakCmd(dummy, interp, argc, argv)
  45.     ClientData dummy;            /* Not used. */
  46.     Tcl_Interp *interp;            /* Current interpreter. */
  47.     int argc;                /* Number of arguments. */
  48.     char **argv;            /* Argument strings. */
  49. {
  50.     if (argc != 1) {
  51.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  52.         argv[0], "\"", (char *) NULL);
  53.     return TCL_ERROR;
  54.     }
  55.     return TCL_BREAK;
  56. }
  57.  
  58. /*
  59.  *----------------------------------------------------------------------
  60.  *
  61.  * Tcl_CaseCmd --
  62.  *
  63.  *    This procedure is invoked to process the "case" Tcl command.
  64.  *    See the user documentation for details on what it does.
  65.  *
  66.  * Results:
  67.  *    A standard Tcl result.
  68.  *
  69.  * Side effects:
  70.  *    See the user documentation.
  71.  *
  72.  *----------------------------------------------------------------------
  73.  */
  74.  
  75.     /* ARGSUSED */
  76. int
  77. Tcl_CaseCmd(dummy, interp, argc, argv)
  78.     ClientData dummy;            /* Not used. */
  79.     Tcl_Interp *interp;            /* Current interpreter. */
  80.     int argc;                /* Number of arguments. */
  81.     char **argv;            /* Argument strings. */
  82. {
  83.     int i, result;
  84.     int body;
  85.     char *string;
  86.     int caseArgc, splitArgs;
  87.     char **caseArgv;
  88.  
  89.     if (argc < 3) {
  90.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  91.         argv[0], " string ?in? patList body ... ?default body?\"",
  92.         (char *) NULL);
  93.     return TCL_ERROR;
  94.     }
  95.     string = argv[1];
  96.     body = -1;
  97.     if (strcmp(argv[2], "in") == 0) {
  98.     i = 3;
  99.     } else {
  100.     i = 2;
  101.     }
  102.     caseArgc = argc - i;
  103.     caseArgv = argv + i;
  104.  
  105.     /*
  106.      * If all of the pattern/command pairs are lumped into a single
  107.      * argument, split them out again.
  108.      */
  109.  
  110.     splitArgs = 0;
  111.     if (caseArgc == 1) {
  112.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  113.     if (result != TCL_OK) {
  114.         return result;
  115.     }
  116.     splitArgs = 1;
  117.     }
  118.  
  119.     for (i = 0; i < caseArgc; i += 2) {
  120.     int patArgc, j;
  121.     char **patArgv;
  122.     register char *p;
  123.  
  124.     if (i == (caseArgc-1)) {
  125.         interp->result = "extra case pattern with no body";
  126.         result = TCL_ERROR;
  127.         goto cleanup;
  128.     }
  129.  
  130.     /*
  131.      * Check for special case of single pattern (no list) with
  132.      * no backslash sequences.
  133.      */
  134.  
  135.     for (p = caseArgv[i]; *p != 0; p++) {
  136.         if (isspace(*p) || (*p == '\\')) {
  137.         break;
  138.         }
  139.     }
  140.     if (*p == 0) {
  141.         if ((*caseArgv[i] == 'd')
  142.             && (strcmp(caseArgv[i], "default") == 0)) {
  143.         body = i+1;
  144.         }
  145.         if (Tcl_StringMatch(string, caseArgv[i])) {
  146.         body = i+1;
  147.         goto match;
  148.         }
  149.         continue;
  150.     }
  151.  
  152.     /*
  153.      * Break up pattern lists, then check each of the patterns
  154.      * in the list.
  155.      */
  156.  
  157.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  158.     if (result != TCL_OK) {
  159.         goto cleanup;
  160.     }
  161.     for (j = 0; j < patArgc; j++) {
  162.         if (Tcl_StringMatch(string, patArgv[j])) {
  163.         body = i+1;
  164.         break;
  165.         }
  166.     }
  167.     ckfree((char *) patArgv);
  168.     if (j < patArgc) {
  169.         break;
  170.     }
  171.     }
  172.  
  173.     match:
  174.     if (body != -1) {
  175.     result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
  176.     if (result == TCL_ERROR) {
  177.         char msg[100];
  178.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
  179.             interp->errorLine);
  180.         Tcl_AddErrorInfo(interp, msg);
  181.     }
  182.     goto cleanup;
  183.     }
  184.  
  185.     /*
  186.      * Nothing matched:  return nothing.
  187.      */
  188.  
  189.     result = TCL_OK;
  190.  
  191.     cleanup:
  192.     if (splitArgs) {
  193.     ckfree((char *) caseArgv);
  194.     }
  195.     return result;
  196. }
  197.  
  198. /*
  199.  *----------------------------------------------------------------------
  200.  *
  201.  * Tcl_CatchCmd --
  202.  *
  203.  *    This procedure is invoked to process the "catch" Tcl command.
  204.  *    See the user documentation for details on what it does.
  205.  *
  206.  * Results:
  207.  *    A standard Tcl result.
  208.  *
  209.  * Side effects:
  210.  *    See the user documentation.
  211.  *
  212.  *----------------------------------------------------------------------
  213.  */
  214.  
  215.     /* ARGSUSED */
  216. int
  217. Tcl_CatchCmd(dummy, interp, argc, argv)
  218.     ClientData dummy;            /* Not used. */
  219.     Tcl_Interp *interp;            /* Current interpreter. */
  220.     int argc;                /* Number of arguments. */
  221.     char **argv;            /* Argument strings. */
  222. {
  223.     int result;
  224.  
  225.     if ((argc != 2) && (argc != 3)) {
  226.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  227.         argv[0], " command ?varName?\"", (char *) NULL);
  228.     return TCL_ERROR;
  229.     }
  230.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  231.     if (argc == 3) {
  232.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  233.         Tcl_SetResult(interp, "couldn't save command result in variable",
  234.             TCL_STATIC);
  235.         return TCL_ERROR;
  236.     }
  237.     }
  238.     Tcl_ResetResult(interp);
  239.     sprintf(interp->result, "%d", result);
  240.     return TCL_OK;
  241. }
  242.  
  243. /*
  244.  *----------------------------------------------------------------------
  245.  *
  246.  * Tcl_ConcatCmd --
  247.  *
  248.  *    This procedure is invoked to process the "concat" Tcl command.
  249.  *    See the user documentation for details on what it does.
  250.  *
  251.  * Results:
  252.  *    A standard Tcl result.
  253.  *
  254.  * Side effects:
  255.  *    See the user documentation.
  256.  *
  257.  *----------------------------------------------------------------------
  258.  */
  259.  
  260.     /* ARGSUSED */
  261. int
  262. Tcl_ConcatCmd(dummy, interp, argc, argv)
  263.     ClientData dummy;            /* Not used. */
  264.     Tcl_Interp *interp;            /* Current interpreter. */
  265.     int argc;                /* Number of arguments. */
  266.     char **argv;            /* Argument strings. */
  267. {
  268.     if (argc == 1) {
  269.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  270.         " arg ?arg ...?\"", (char *) NULL);
  271.     return TCL_ERROR;
  272.     }
  273.  
  274.     interp->result = Tcl_Concat(argc-1, argv+1);
  275.     interp->freeProc = (Tcl_FreeProc *) free;
  276.     return TCL_OK;
  277. }
  278.  
  279. /*
  280.  *----------------------------------------------------------------------
  281.  *
  282.  * Tcl_ContinueCmd --
  283.  *
  284.  *    This procedure is invoked to process the "continue" Tcl command.
  285.  *    See the user documentation for details on what it does.
  286.  *
  287.  * Results:
  288.  *    A standard Tcl result.
  289.  *
  290.  * Side effects:
  291.  *    See the user documentation.
  292.  *
  293.  *----------------------------------------------------------------------
  294.  */
  295.  
  296.     /* ARGSUSED */
  297. int
  298. Tcl_ContinueCmd(dummy, interp, argc, argv)
  299.     ClientData dummy;            /* Not used. */
  300.     Tcl_Interp *interp;            /* Current interpreter. */
  301.     int argc;                /* Number of arguments. */
  302.     char **argv;            /* Argument strings. */
  303. {
  304.     if (argc != 1) {
  305.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  306.         "\"", (char *) NULL);
  307.     return TCL_ERROR;
  308.     }
  309.     return TCL_CONTINUE;
  310. }
  311.  
  312. /*
  313.  *----------------------------------------------------------------------
  314.  *
  315.  * Tcl_ErrorCmd --
  316.  *
  317.  *    This procedure is invoked to process the "error" Tcl command.
  318.  *    See the user documentation for details on what it does.
  319.  *
  320.  * Results:
  321.  *    A standard Tcl result.
  322.  *
  323.  * Side effects:
  324.  *    See the user documentation.
  325.  *
  326.  *----------------------------------------------------------------------
  327.  */
  328.  
  329.     /* ARGSUSED */
  330. int
  331. Tcl_ErrorCmd(dummy, interp, argc, argv)
  332.     ClientData dummy;            /* Not used. */
  333.     Tcl_Interp *interp;            /* Current interpreter. */
  334.     int argc;                /* Number of arguments. */
  335.     char **argv;            /* Argument strings. */
  336. {
  337.     Interp *iPtr = (Interp *) interp;
  338.  
  339.     if ((argc < 2) || (argc > 4)) {
  340.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  341.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  342.     return TCL_ERROR;
  343.     }
  344.     if ((argc >= 3) && (argv[2][0] != 0)) {
  345.     Tcl_AddErrorInfo(interp, argv[2]);
  346.     iPtr->flags |= ERR_ALREADY_LOGGED;
  347.     }
  348.     if (argc == 4) {
  349.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  350.         TCL_GLOBAL_ONLY);
  351.     iPtr->flags |= ERROR_CODE_SET;
  352.     }
  353.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  354.     return TCL_ERROR;
  355. }
  356.  
  357. /*
  358.  *----------------------------------------------------------------------
  359.  *
  360.  * Tcl_EvalCmd --
  361.  *
  362.  *    This procedure is invoked to process the "eval" Tcl command.
  363.  *    See the user documentation for details on what it does.
  364.  *
  365.  * Results:
  366.  *    A standard Tcl result.
  367.  *
  368.  * Side effects:
  369.  *    See the user documentation.
  370.  *
  371.  *----------------------------------------------------------------------
  372.  */
  373.  
  374.     /* ARGSUSED */
  375. int
  376. Tcl_EvalCmd(dummy, interp, argc, argv)
  377.     ClientData dummy;            /* Not used. */
  378.     Tcl_Interp *interp;            /* Current interpreter. */
  379.     int argc;                /* Number of arguments. */
  380.     char **argv;            /* Argument strings. */
  381. {
  382.     int result;
  383.     char *cmd;
  384.  
  385.     if (argc < 2) {
  386.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  387.         " arg ?arg ...?\"", (char *) NULL);
  388.     return TCL_ERROR;
  389.     }
  390.     if (argc == 2) {
  391.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  392.     } else {
  393.     
  394.     /*
  395.      * More than one argument:  concatenate them together with spaces
  396.      * between, then evaluate the result.
  397.      */
  398.     
  399.     cmd = Tcl_Concat(argc-1, argv+1);
  400.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  401.     ckfree(cmd);
  402.     }
  403.     if (result == TCL_ERROR) {
  404.     char msg[60];
  405.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  406.     Tcl_AddErrorInfo(interp, msg);
  407.     }
  408.     return result;
  409. }
  410.  
  411. /*
  412.  *----------------------------------------------------------------------
  413.  *
  414.  * Tcl_ExprCmd --
  415.  *
  416.  *    This procedure is invoked to process the "expr" Tcl command.
  417.  *    See the user documentation for details on what it does.
  418.  *
  419.  * Results:
  420.  *    A standard Tcl result.
  421.  *
  422.  * Side effects:
  423.  *    See the user documentation.
  424.  *
  425.  *----------------------------------------------------------------------
  426.  */
  427.  
  428.     /* ARGSUSED */
  429. int
  430. Tcl_ExprCmd(dummy, interp, argc, argv)
  431.     ClientData dummy;            /* Not used. */
  432.     Tcl_Interp *interp;            /* Current interpreter. */
  433.     int argc;                /* Number of arguments. */
  434.     char **argv;            /* Argument strings. */
  435. {
  436.     if (argc != 2) {
  437.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  438.         " expression\"", (char *) NULL);
  439.     return TCL_ERROR;
  440.     }
  441.  
  442.     return Tcl_ExprString(interp, argv[1]);
  443. }
  444.  
  445. /*
  446.  *----------------------------------------------------------------------
  447.  *
  448.  * Tcl_ForCmd --
  449.  *
  450.  *    This procedure is invoked to process the "for" Tcl command.
  451.  *    See the user documentation for details on what it does.
  452.  *
  453.  * Results:
  454.  *    A standard Tcl result.
  455.  *
  456.  * Side effects:
  457.  *    See the user documentation.
  458.  *
  459.  *----------------------------------------------------------------------
  460.  */
  461.  
  462.     /* ARGSUSED */
  463. int
  464. Tcl_ForCmd(dummy, interp, argc, argv)
  465.     ClientData dummy;            /* Not used. */
  466.     Tcl_Interp *interp;            /* Current interpreter. */
  467.     int argc;                /* Number of arguments. */
  468.     char **argv;            /* Argument strings. */
  469. {
  470.     int result, value;
  471.  
  472.     if (argc != 5) {
  473.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  474.         " start test next command\"", (char *) NULL);
  475.     return TCL_ERROR;
  476.     }
  477.  
  478.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  479.     if (result != TCL_OK) {
  480.     if (result == TCL_ERROR) {
  481.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  482.     }
  483.     return result;
  484.     }
  485.     while (1) {
  486.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  487.     if (result != TCL_OK) {
  488.         return result;
  489.     }
  490.     if (!value) {
  491.         break;
  492.     }
  493.     result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
  494.     if (result == TCL_CONTINUE) {
  495.         result = TCL_OK;
  496.     } else if (result != TCL_OK) {
  497.         if (result == TCL_ERROR) {
  498.         char msg[60];
  499.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  500.         Tcl_AddErrorInfo(interp, msg);
  501.         }
  502.         break;
  503.     }
  504.     result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
  505.     if (result == TCL_BREAK) {
  506.         break;
  507.     } else if (result != TCL_OK) {
  508.         if (result == TCL_ERROR) {
  509.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  510.         }
  511.         return result;
  512.     }
  513.     }
  514.     if (result == TCL_BREAK) {
  515.     result = TCL_OK;
  516.     }
  517.     if (result == TCL_OK) {
  518.     Tcl_ResetResult(interp);
  519.     }
  520.     return result;
  521. }
  522.  
  523. /*
  524.  *----------------------------------------------------------------------
  525.  *
  526.  * Tcl_ForeachCmd --
  527.  *
  528.  *    This procedure is invoked to process the "foreach" Tcl command.
  529.  *    See the user documentation for details on what it does.
  530.  *
  531.  * Results:
  532.  *    A standard Tcl result.
  533.  *
  534.  * Side effects:
  535.  *    See the user documentation.
  536.  *
  537.  *----------------------------------------------------------------------
  538.  */
  539.  
  540.     /* ARGSUSED */
  541. int
  542. Tcl_ForeachCmd(dummy, interp, argc, argv)
  543.     ClientData dummy;            /* Not used. */
  544.     Tcl_Interp *interp;            /* Current interpreter. */
  545.     int argc;                /* Number of arguments. */
  546.     char **argv;            /* Argument strings. */
  547. {
  548.     int listArgc, i, result;
  549.     char **listArgv;
  550.  
  551.     if (argc != 4) {
  552.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  553.         " varName list command\"", (char *) NULL);
  554.     return TCL_ERROR;
  555.     }
  556.  
  557.     /*
  558.      * Break the list up into elements, and execute the command once
  559.      * for each value of the element.
  560.      */
  561.  
  562.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  563.     if (result != TCL_OK) {
  564.     return result;
  565.     }
  566.     for (i = 0; i < listArgc; i++) {
  567.     if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
  568.         Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
  569.         result = TCL_ERROR;
  570.         break;
  571.     }
  572.  
  573.     result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
  574.     if (result != TCL_OK) {
  575.         if (result == TCL_CONTINUE) {
  576.         result = TCL_OK;
  577.         } else if (result == TCL_BREAK) {
  578.         result = TCL_OK;
  579.         break;
  580.         } else if (result == TCL_ERROR) {
  581.         char msg[100];
  582.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  583.             interp->errorLine);
  584.         Tcl_AddErrorInfo(interp, msg);
  585.         break;
  586.         } else {
  587.         break;
  588.         }
  589.     }
  590.     }
  591.     ckfree((char *) listArgv);
  592.     if (result == TCL_OK) {
  593.     Tcl_ResetResult(interp);
  594.     }
  595.     return result;
  596. }
  597.  
  598. /*
  599.  *----------------------------------------------------------------------
  600.  *
  601.  * Tcl_FormatCmd --
  602.  *
  603.  *    This procedure is invoked to process the "format" Tcl command.
  604.  *    See the user documentation for details on what it does.
  605.  *
  606.  * Results:
  607.  *    A standard Tcl result.
  608.  *
  609.  * Side effects:
  610.  *    See the user documentation.
  611.  *
  612.  *----------------------------------------------------------------------
  613.  */
  614.  
  615.     /* ARGSUSED */
  616. int
  617. Tcl_FormatCmd(dummy, interp, argc, argv)
  618.     ClientData dummy;            /* Not used. */
  619.     Tcl_Interp *interp;            /* Current interpreter. */
  620.     int argc;                /* Number of arguments. */
  621.     char **argv;            /* Argument strings. */
  622. {
  623.     register char *format;    /* Used to read characters from the format
  624.                  * string. */
  625.     char newFormat[40];        /* A new format specifier is generated here. */
  626.     int width;            /* Field width from field specifier, or 0 if
  627.                  * no width given. */
  628.     int precision;        /* Field precision from field specifier, or 0
  629.                  * if no precision given. */
  630.     int size;            /* Number of bytes needed for result of
  631.                  * conversion, based on type of conversion
  632.                  * ("e", "s", etc.) and width from above. */
  633.     char *oneWordValue = NULL;    /* Used to hold value to pass to sprintf, if
  634.                  * it's a one-word value. */
  635.     double twoWordValue;    /* Used to hold value to pass to sprintf if
  636.                  * it's a two-word value. */
  637.     int useTwoWords;        /* 0 means use oneWordValue, 1 means use
  638.                  * twoWordValue. */
  639.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  640.                  * interp->resultSpace, but may get dynamically
  641.                  * re-allocated if this isn't enough. */
  642.     int dstSize = 0;        /* Number of non-null characters currently
  643.                  * stored at dst. */
  644.     int dstSpace = TCL_RESULT_SIZE;
  645.                 /* Total amount of storage space available
  646.                  * in dst (not including null terminator. */
  647.     int noPercent;        /* Special case for speed:  indicates there's
  648.                  * no field specifier, just a string to copy. */
  649.     char **curArg;        /* Remainder of argv array. */
  650.     int useShort;        /* Value to be printed is short (half word). */
  651.  
  652.     /*
  653.      * This procedure is a bit nasty.  The goal is to use sprintf to
  654.      * do most of the dirty work.  There are several problems:
  655.      * 1. this procedure can't trust its arguments.
  656.      * 2. we must be able to provide a large enough result area to hold
  657.      *    whatever's generated.  This is hard to estimate.
  658.      * 2. there's no way to move the arguments from argv to the call
  659.      *    to sprintf in a reasonable way.  This is particularly nasty
  660.      *    because some of the arguments may be two-word values (doubles).
  661.      * So, what happens here is to scan the format string one % group
  662.      * at a time, making many individual calls to sprintf.
  663.      */
  664.  
  665.     if (argc < 2) {
  666.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  667.         " formatString ?arg arg ...?\"", (char *) NULL);
  668.     return TCL_ERROR;
  669.     }
  670.     curArg = argv+2;
  671.     argc -= 2;
  672.     for (format = argv[1]; *format != 0; ) {
  673.     register char *newPtr = newFormat;
  674.  
  675.     width = precision = useTwoWords = noPercent = useShort = 0;
  676.  
  677.     /*
  678.      * Get rid of any characters before the next field specifier.
  679.      * Collapse backslash sequences found along the way.
  680.      */
  681.  
  682.     if (*format != '%') {
  683.         register char *p;
  684.         int bsSize;
  685.  
  686.         oneWordValue = p = format;
  687.         while ((*format != '%') && (*format != 0)) {
  688.         if (*format == '\\') {
  689.             *p = Tcl_Backslash(format, &bsSize);
  690.             if (*p != 0) {
  691.             p++;
  692.             }
  693.             format += bsSize;
  694.         } else {
  695.             *p = *format;
  696.             p++;
  697.             format++;
  698.         }
  699.         }
  700.         size = p - oneWordValue;
  701.         noPercent = 1;
  702.         goto doField;
  703.     }
  704.  
  705.     if (format[1] == '%') {
  706.         oneWordValue = format;
  707.         size = 1;
  708.         noPercent = 1;
  709.         format += 2;
  710.         goto doField;
  711.     }
  712.  
  713.     /*
  714.      * Parse off a field specifier, compute how many characters
  715.      * will be needed to store the result, and substitute for
  716.      * "*" size specifiers.
  717.      */
  718.  
  719.     *newPtr = '%';
  720.     newPtr++;
  721.     format++;
  722.     while ((*format == '-') || (*format == '#') || (*format == '0')
  723.         || (*format == ' ') || (*format == '+')) {
  724.         *newPtr = *format;
  725.         newPtr++;
  726.         format++;
  727.     }
  728.     if (isdigit(*format)) {
  729.         width = atoi(format);
  730.         do {
  731.         format++;
  732.         } while (isdigit(*format));
  733.     } else if (*format == '*') {
  734.         if (argc <= 0) {
  735.         goto notEnoughArgs;
  736.         }
  737.         if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) {
  738.         goto fmtError;
  739.         }
  740.         argc--;
  741.         curArg++;
  742.         format++;
  743.     }
  744.     if (width != 0) {
  745.         sprintf(newPtr, "%d", width);
  746.         while (*newPtr != 0) {
  747.         newPtr++;
  748.         }
  749.     }
  750.     if (*format == '.') {
  751.         *newPtr = '.';
  752.         newPtr++;
  753.         format++;
  754.     }
  755.     if (isdigit(*format)) {
  756.         precision = atoi(format);
  757.         do {
  758.         format++;
  759.         } while (isdigit(*format));
  760.     } else if (*format == '*') {
  761.         if (argc <= 0) {
  762.         goto notEnoughArgs;
  763.         }
  764.         if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) {
  765.         goto fmtError;
  766.         }
  767.         argc--;
  768.         curArg++;
  769.         format++;
  770.     }
  771.     if (precision != 0) {
  772.         sprintf(newPtr, "%d", precision);
  773.         while (*newPtr != 0) {
  774.         newPtr++;
  775.         }
  776.     }
  777.     if (*format == 'l') {
  778.         format++;
  779.     } else if (*format == 'h') {
  780.         useShort = 1;
  781.         *newPtr = 'h';
  782.         newPtr++;
  783.         format++;
  784.     }
  785.     *newPtr = *format;
  786.     newPtr++;
  787.     *newPtr = 0;
  788.     if (argc <= 0) {
  789.         goto notEnoughArgs;
  790.     }
  791.     switch (*format) {
  792.         case 'D':
  793.         case 'O':
  794.         case 'U':
  795.         if (!useShort) {
  796.             newPtr++;
  797.         } else {
  798.             useShort = 0;
  799.         }
  800.         newPtr[-1] = tolower(*format);
  801.         newPtr[-2] = 'l';
  802.         *newPtr = 0;
  803.         case 'd':
  804.         case 'o':
  805.         case 'u':
  806.         case 'x':
  807.         case 'X':
  808.         if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
  809.             != TCL_OK) {
  810.             goto fmtError;
  811.         }
  812.         size = 40;
  813.         break;
  814.         case 's':
  815.         oneWordValue = *curArg;
  816.         size = strlen(*curArg);
  817.         break;
  818.         case 'c':
  819.         if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
  820.             != TCL_OK) {
  821.             goto fmtError;
  822.         }
  823.         size = 1;
  824.         break;
  825.         case 'F':
  826.         newPtr[-1] = tolower(newPtr[-1]);
  827.         case 'e':
  828.         case 'E':
  829.         case 'f':
  830.         case 'g':
  831.         case 'G':
  832.         if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) {
  833.             goto fmtError;
  834.         }
  835.         useTwoWords = 1;
  836.         size = 320;
  837.         if (precision > 10) {
  838.             size += precision;
  839.         }
  840.         break;
  841.         case 0:
  842.         interp->result =
  843.             "format string ended in middle of field specifier";
  844.         goto fmtError;
  845.         default:
  846.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  847.         goto fmtError;
  848.     }
  849.     argc--;
  850.     curArg++;
  851.     format++;
  852.  
  853.     /*
  854.      * Make sure that there's enough space to hold the formatted
  855.      * result, then format it.
  856.      */
  857.  
  858.     doField:
  859.     if (width > size) {
  860.         size = width;
  861.     }
  862.     if ((dstSize + size) > dstSpace) {
  863.         char *newDst;
  864.         int newSpace;
  865.  
  866.         newSpace = 2*(dstSize + size);
  867.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  868.         if (dstSize != 0) {
  869.         memcpy((VOID *) newDst, (VOID *) dst, dstSize);
  870.         }
  871.         if (dstSpace != TCL_RESULT_SIZE) {
  872.         ckfree(dst);
  873.         }
  874.         dst = newDst;
  875.         dstSpace = newSpace;
  876.     }
  877.     if (noPercent) {
  878.         memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size);
  879.         dstSize += size;
  880.         dst[dstSize] = 0;
  881.     } else {
  882.         if (useTwoWords) {
  883.         sprintf(dst+dstSize, newFormat, twoWordValue);
  884.         } else if (useShort) {
  885.         /*
  886.          * The double cast below is needed for a few machines
  887.          * (e.g. Pyramids as of 1/93) that don't like casts
  888.          * directly from pointers to shorts.
  889.          */
  890.  
  891.         sprintf(dst+dstSize, newFormat, (short) (int) oneWordValue);
  892.         } else {
  893.         sprintf(dst+dstSize, newFormat, (char *) oneWordValue);
  894.         }
  895.         dstSize += strlen(dst+dstSize);
  896.     }
  897.     }
  898.  
  899.     interp->result = dst;
  900.     if (dstSpace != TCL_RESULT_SIZE) {
  901.     interp->freeProc = (Tcl_FreeProc *) free;
  902.     } else {
  903.     interp->freeProc = 0;
  904.     }
  905.     return TCL_OK;
  906.  
  907.     notEnoughArgs:
  908.     interp->result = "not enough arguments for all format specifiers";
  909.     fmtError:
  910.     if (dstSpace != TCL_RESULT_SIZE) {
  911.     ckfree(dst);
  912.     }
  913.     return TCL_ERROR;
  914. }
  915.